﻿Imports System.Runtime.InteropServices
'https://docs.microsoft.com/zh-cn/windows/win32/dwm/customframe?redirectedfrom=MSDN#appendix-a-sample-window-procedure
Module WinDwm
    Const WM_CREATE As Integer = &H1
    Const WM_ACTIVATE As Integer = &H6
    Const WM_PAINT As Integer = &HF
    Const WM_NCCALCSIZE As Integer = &H83
    Const WM_NCHITTEST As Integer = &H84
    ''' <summary>当用户从菜单中选择命令项、控件向其父窗口发送通知消息或翻译快捷键击键时发送。</summary>
    Const WM_COMMAND As Integer = &H111
    ''' <summary>当窗口被销毁时发送。 在窗口从屏幕中删除后，它会被发送到窗口的窗口过程。</summary>
    Const WM_DESTROY As Integer = &H2

    Const SWP_FRAMECHANGED As Integer = &H20

    Const LEFTEXTENDWIDTH = 8
    Const RIGHTEXTENDWIDTH = 8
    Const BOTTOMEXTENDWIDTH = 20
    Const TOPEXTENDWIDTH = 27
    Const BI_RGB = 0&
    Private Const DIB_PAL_COLORS = 1
    Private Const DIB_RGB_COLORS = 0

    Private Const LF_FACESIZE = 32
    Private Const TMT_CAPTIONFONT = 801
    Private Const SRCCOPY = &HCC0020

    Public Const GWL_WNDPROC = (-4)

    '----------------光标作用点的位置------------------
    ''' <summary>在屏幕背景上，或在 windows (与 HTNOWHERE 相同的分隔线上，不同之处在于 DefWindowProc 函数会发出系统提示音，指示) 错误。 </summary>
    Const HTERROR = -2
    ''' <summary>在同一线程中的另一个窗口当前覆盖的窗口中 (消息将在同一线程中发送到基础窗口，直到其中一个窗口返回不 HTTRANSPARENT 的代码) 。</summary>
    Const HTTRANSPARENT = -1
    ''' <summary>在屏幕背景上或窗口之间的分隔线上</summary>
    Const HTNOWHERE = 0
    ''' <summary>在工作区中。</summary>
    Const HTCLIENT = 1
    ''' <summary>在标题栏中。</summary>
    Const HTCAPTION = 2
    ''' <summary>在窗口菜单或子窗口的 " 关闭 " 按钮中。</summary>
    Const HTSYSMENU = 3
    ''' <summary>在 "大小" 框中 (与 HTSIZE) 相同。</summary>
    Const HTGROWBOX = 4
    ''' <summary>在 "大小" 框中 (与 HTGROWBOX) 相同。</summary>
    Const HTSIZE = HTGROWBOX
    ''' <summary>在菜单中。</summary>
    Const HTMENU = 5
    ''' <summary>水平滚动条中的。</summary>
    Const HTHSCROLL = 6
    ''' <summary>垂直滚动条。</summary>
    Const HTVSCROLL = 7
    ''' <summary>在 "最小化" 按钮中。</summary>
    Const HTMINBUTTON = 8
    ''' <summary>在 "最小化" 按钮中。与HTMINBUTTON相同</summary>
    Const HTREDUCE = HTMINBUTTON
    ''' <summary>"最大化" 按钮。</summary>
    Const HTMAXBUTTON = 9
    ''' <summary>"最大化" 按钮。与HTMAXBUTTON相同</summary>
    Const HTZOOM = HTMAXBUTTON
    ''' <summary>在可调整大小的窗口的左边框中 (用户可以单击鼠标来水平调整窗口) 。</summary>
    Const HTLEFT = 10
    ''' <summary>在可调整大小的窗口的右边框 (用户可以单击鼠标来水平调整窗口) 。</summary>
    Const HTRIGHT = 11
    ''' <summary>在窗口的上边框。</summary>
    Const HTTOP = 12
    ''' <summary>在窗口边框的左上角。</summary>
    Const HTTOPLEFT = 13
    ''' <summary>在窗口边框的右上角。 </summary>
    Const HTTOPRIGHT = 14
    ''' <summary>在可调整大小的窗口的下水平边框 (用户可以单击鼠标将窗口垂直调整) 。</summary>
    Const HTBOTTOM = 15
    ''' <summary>没有大小调整边框的窗口边框。</summary>
    Const HTBORDER = 18
    ''' <summary>在可调整大小的窗口的边框的左下角 (用户可以单击鼠标以沿对角) 调整窗口的大小。</summary>
    Const HTBOTTOMLEFT = 16
    ''' <summary>在可调整大小的窗口的边框右下角 (用户可以单击鼠标以沿对角) 调整窗口的大小。</summary>
    Const HTBOTTOMRIGHT = 17
    ''' <summary> 在 "关闭" 按钮中。</summary>
    Const HTCLOSE = 20
    ''' <summary>在 "帮助" 按钮中。</summary>
    Const HTHELP = 21
    '----------------------------------------------
    ''' <summary>
    ''' The crText member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_TEXTCOLOR = 0
    ''' <summary>
    ''' The crBorder member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_BORDERCOLOR = 1
    ''' <summary>
    ''' The crShadow member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_SHADOWCOLOR = 2
    ''' <summary>
    ''' The iTextShadowType member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_SHADOWTYPE = 3
    ''' <summary>
    ''' The ptShadowOffset member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_SHADOWOFFSET = 4
    ''' <summary>
    ''' The iBorderSize member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_BORDERSIZE = 5
    ''' <summary>
    ''' The iFontPropId member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_FONTPROP = 6
    ''' <summary>
    ''' The iColorPropId member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_COLORPROP = 7
    ''' <summary>
    ''' The iStateId member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_STATEID = 8
    ''' <summary>
    ''' The pRect parameter of the DrawThemeTextEx function that uses this structure will be used as both an in and an out parameter. After the function returns, the pRect parameter will contain the rectangle that corresponds to the region calculated to be drawn. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_CALCRECT = 9
    ''' <summary>
    ''' The fApplyOverlay member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_APPLYOVERLAY = 10
    ''' <summary>
    ''' The iGlowSize member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_GLOWSIZE = 11
    ''' <summary>
    ''' The pfnDrawTextCallback member value is valid. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_CALLBACK = 12
    ''' <summary>
    ''' Draws text with antialiased alpha. Use of this flag requires a top-down DIB section. This flag works only if the HDC passed to function DrawThemeTextEx has a top-down DIB section currently selected in it. For more information, see Device-Independent Bitmaps. 
    ''' </summary>
    ''' <remarks></remarks>
    Const DTT_COMPOSITED = 13
    Const DTT_VALIDBITS = DTT_TEXTCOLOR Or DTT_BORDERCOLOR Or DTT_SHADOWCOLOR Or DTT_SHADOWTYPE Or DTT_SHADOWOFFSET Or DTT_BORDERSIZE Or DTT_FONTPROP Or DTT_COLORPROP Or DTT_STATEID Or DTT_CALCRECT Or DTT_APPLYOVERLAY Or DTT_GLOWSIZE Or DTT_COMPOSITED
    '''''''''''''''''''''''''''''''''''窗体样式''''''''''''''''''''''''''''''''''''''''''''
    '''<summary>产生一个层叠的窗口，一个层叠的窗口有一个标题栏和一个边框</summary>
    Const WS_OVERLAPPED = &H0
    '''<summary>创建一个有标题栏的窗口</summary>
    Const WS_CAPTION = &HC00000
    ''' <summary>创建一个在标题栏上带有系统菜单的窗口，要和WS_CAPTION类 型一起使用</summary>
    Const WS_SYSMENU = &H80000
    ''' <summary> 创建一个具有可调边框的窗口</summary>
    Const WS_THICKFRAME = &H40000
    ''' <summary>创建一个具有最小化按钮的窗口，必须同时设定WS_ SYSMENU类型</summary>
    Const WS_MINIMIZEBOX = &H20000
    ''' <summary>创建一个具有最大化按钮的窗口，必须同时设定WS_ SYSMENU类型</summary>
    Const WS_MAXIMIZEBOX = &H10000
    Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)

    Private Const DT_VCENTER = &H4
    Private Const DT_WORD_ELLIPSIS = &H40000
    Private Const DT_TOP = &H0
    Private Const DT_LEFT = &H0
    Private Const DT_RIGHT = &H2
    Private Const DT_BOTTOM = &H8
    Private Const DT_CENTER = &H1
    Private Const DT_SINGLELINE = &H20
    Private Const DT_NOPREFIX = &H800
    Private Const TEXT_LABEL = &H8

    <StructLayout(LayoutKind.Sequential)> _
    Private Structure RECT
        Dim left As Integer
        Dim top As Integer
        Dim right As Integer
        Dim bottom As Integer
    End Structure
    <StructLayout(LayoutKind.Sequential)> _
    Private Structure MARGINS
        Dim cxLeftWidth As Integer
        Dim cxRightWidth As Integer
        Dim cyTopHeight As Integer
        Dim cyBottomHeight As Integer
    End Structure
    <StructLayout(LayoutKind.Sequential)> _
    Public Structure DWM_BLURBEHIND
        Public dwFlags As Integer
        Public fEnable As Integer
        Public hRgnBlur As IntPtr
        Public fTransitionOnMaximized As Integer
    End Structure
    <StructLayout(LayoutKind.Sequential)> _
    Private Structure PAINTSTRUCT
        Dim hdc As IntPtr
        Dim fErase As Boolean
        Dim rcPaint As RECT
        Dim fRestore As Boolean
        Dim fIncUpdate As Boolean
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=31)> _
        Dim rgbReserved() As Byte
    End Structure
    Private Structure PWINDOWPOS
        Dim hwnd As IntPtr  '窗口句柄
        Dim hWndInsertAfter As IntPtr '标识了一个窗口，本窗口将被放在这个窗口的后面。
        Dim x As Integer '指定了窗口的左边界的位置。
        Dim y As Integer '指定了窗口的右边界的位置。
        Dim cx As Integer '指定了窗口的宽度，以象素为单位。
        Dim cy As Integer '指定了窗口的高度，以象素为单位。
        Dim flags As UInteger
        '指定了窗口位置的选项。这个成员可以是下列值之一：
        '	SWP_DRAWFRAME	画出窗口的边框（在窗口类的描述中定义）。窗口接收到一个WM_NCCALCSIZE消息。
        '	SWP_FRAMECHANGED	向窗口发送一个WM_NCCALCSIZE消息，即使没有改变窗口的大小。如果没有指定这个标志，仅当窗口的大小发生变化时才发送WM_NCCALCSIZE消息。
        '	SWP_HIDEWINDOW	隐藏窗口。
        '	SWP_NOACTIVATE	不激活窗口。
        '	SWP_NOCOPYBITS	废弃客户区的全部内容。如果没有指定这个标志，将会保存客户区的有效内容并在窗口被改变大小或重定位以后回送到客户区。
        '	SWP_NOMOVE	保留当前位置（忽略x和y成员）。
        '	SWP_NOOWNERZORDER	不改变所有者窗口在Z轴上的顺序。
        '	SWP_NOSIZE	保留当前大小（忽略cx和cy成员）。
        '	SWP_NOREDRAW	不重画改变的内容。
        '	SWP_NOREPOSITION	与SWP_NOOWNERZORDER相同。
        '	SWP_NOSENDCHANGING	防止窗口接收WM_WINDOWPOSCHANGING消息。
        '	SWP_NOZORDER	保留当前顺序（忽略hwndInsertAfter成员）
    End Structure
    <StructLayout(LayoutKind.Sequential)> _
    Private Structure NCCALCSIZE_PARAMS
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=2)> _
        Dim rgrc() As RECT
        Dim lppos As PWINDOWPOS
    End Structure
    Private Structure BITMAPINFOHEADER
        Dim biSize As Int32
        Dim biWidth As Int32
        Dim biHeight As Int32
        Dim biPlanes As Int16
        Dim biBitCount As Int16
        Dim biCompression As Int32
        Dim biSizeImage As Int32
        Dim biXPelsPerMeter As Int32
        Dim biYPelsPerMeter As Int32
        Dim biClrUsed As Int32
        Dim biClrImportant As Int32
    End Structure
    Private Structure RGBQUAD
        Dim rgbBlue As Byte
        Dim rgbGreen As Byte
        Dim rgbRed As Byte
        Dim rgbReserved As Byte
    End Structure
    ' Private Structure BITMAPINFO
    '  Dim bmiHeader As BITMAPINFOHEADER
    ' <MarshalAs(UnmanagedType.ByValArray, SizeConst:=1)> _
    '  Dim bmiColors() As RGBQUAD
    ' End Structure
    Private Structure BITMAPINFO
        Dim bmiHeader As BITMAPINFOHEADER
        Dim bmiColors As RGBQUAD
    End Structure

    Private Structure POINTAPI
        Dim x As Integer
        Dim y As Integer
    End Structure
    Private Structure DTTOPTS
        Dim dwSize As Integer
        Dim dwFlags As Integer
        Dim crText As Integer
        Dim crBorder As Integer
        Dim crShadow As Integer
        Dim iTextShadowType As Integer
        Dim ptShadowOffset As POINTAPI
        Dim iBorderSize As Integer
        Dim iFontPropId As Integer
        Dim iColorPropId As Integer
        Dim iStateId As Integer
        Dim fApplyOverlay As Boolean
        Dim iGlowSize As Integer
        Dim pfnDrawTextCallback As IntPtr
        Dim lParam As IntPtr
    End Structure
    Private Structure LOGFONTW
        Dim lfHeight As Long
        Dim lfWidth As Long
        Dim lfEscapement As Long
        Dim lfOrientation As Long
        Dim lfWeight As Long
        Dim lfItalic As Byte
        Dim lfUnderline As Byte
        Dim lfStrikeOut As Byte
        Dim lfCharSet As Byte
        Dim lfOutPrecision As Byte
        Dim lfClipPrecision As Byte
        Dim lfQuality As Byte
        Dim lfPitchAndFamily As Byte
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=LF_FACESIZE - 1)> _
        Dim lfFaceName() As Char
    End Structure
    Private Structure LPPOINT
        Dim x As Long
        Dim y As Long
    End Structure
    Private Const DWM_BB_ENABLE As Integer = &H1
    Private Const DWM_BB_BLURREGION As Integer = &H2
    Private Const DWM_BB_TRANSITIONONMAXIMIZED As Integer = &H4
    Enum HRESULT As Integer
        ''' <summary>操作成功</summary>
        S_OK = 0
        ''' <summary>未实现</summary>
        E_NOTIMPL = &H80004001
        ''' <summary>不支持这样的接口</summary>
        E_NOINTERFACE = &H80004002
        ''' <summary>无效的指针</summary>
        E_POINTER = &H80004003
        ''' <summary>操作中止</summary>
        E_ABORT = &H80004004
        ''' <summary>未指明的故障</summary>
        E_FAIL = &H80004005
        ''' <summary>意外故障</summary>
        E_UNEXPECTED = &H8000FFFF
        ''' <summary>常规访问被拒绝错误</summary>
        E_ACCESSDENIED = &H80070005
        ''' <summary>无效的句柄</summary>
        E_HANDLE = &H80070006
        ''' <summary>无法分配必要的内存</summary>
        E_OUTOFMEMORY = &H8007000E
        ''' <summary>一个或多个参数无效</summary>
        E_INVALIDARG = &H80070057
    End Enum
    Private Declare Function DwmEnableBlurBehindWindow Lib "dwmapi.dll" (ByVal hWnd As IntPtr, ByRef pBlurBehind As DWM_BLURBEHIND) As IntPtr

    '<DllImport("dwmapi.dll", PreserveSig:=False)> _
    'Private Function DwmIsCompositionEnabled(ByRef pfEnabled As Boolean) As IntPtr
    'End Function
    Private Declare Function DwmIsCompositionEnabled Lib "dwmapi.dll" (ByRef pfEnabled As Boolean) As IntPtr
    ''' <summary>
    ''' 默认窗口过程在非客户区域内进行了命中测试。
    ''' </summary>
    ''' <param name="hWnd"></param>
    ''' <param name="msg"></param>
    ''' <param name="wParam"></param>
    ''' <param name="lParam"></param>
    ''' <remarks></remarks>
    Private Declare Function DwmDefWindowProc Lib "dwmapi.dll" (ByVal hWnd As IntPtr, ByVal msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr, ByRef plResult As IntPtr) As Boolean
    Private Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi.dll" (ByVal hWnd As IntPtr, ByRef pMarInset As MARGINS) As IntPtr
    Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hWnd As IntPtr, ByRef lpRect As RECT) As Boolean
    Private Declare Function SetWindowPos Lib "user32.dll" (ByVal hWnd As IntPtr, ByVal hWndlnsertAfter As Integer, ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal uFlags As UInteger) As Boolean
    Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Integer, ByVal nlndex As Integer, ByVal wNewLong As WndProcDelegate) As IntPtr
    Private Declare Function BeginPaint Lib "user32.dll" (ByVal hwnd As IntPtr, ByRef lpPaint As PAINTSTRUCT) As IntPtr
    Private Declare Function EndPaint Lib "user32.dll" (ByVal hwnd As IntPtr, ByRef lpPaint As PAINTSTRUCT) As IntPtr
    Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcA" (ByVal hwnd As IntPtr, ByVal Msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
    Private Declare Sub PostQuitMessage Lib "user32.dll" (ByVal nExitCode As Integer)
    Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As IntPtr, ByRef lpRect As RECT) As Boolean
    Private Declare Function AdjustWindowRectEx Lib "user32.dll" (ByRef lpRect As RECT, ByVal dsStyle As Int32, ByVal bMenu As Int32, ByVal dwEsStyle As Int32) As Boolean
    Private Declare Function OpenThemeData Lib "uxtheme.dll" (ByVal hwnd As IntPtr, ByVal pszClassList As IntPtr) As Int32
    Private Declare Function GetThemeSysFont Lib "UxTheme.dll" (ByVal hTheme As IntPtr, ByVal iFontId As Int32, ByRef plf As LOGFONTW) As IntPtr
    <DllImport("uxtheme.dll", CharSet:=CharSet.Unicode)> _
    Private Function DrawThemeTextEx(ByVal hTheme As IntPtr, ByVal hdc As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer, ByVal pszText As String, ByVal iCharCount As Integer, ByVal flags As UInteger, ByRef rect As RECT, ByRef poptions As DTTOPTS) As Int32
    End Function
    ' Private Declare Function DrawThemeTextEx Lib "UxTheme.dll" (ByVal hTheme As IntPtr, ByVal hdc As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer, ByVal pszText As IntPtr, ByVal cchText As Integer, ByVal dwTextFlags As Integer, ByRef pRect As RECT, ByRef pOptions As DTTOPTS) As Int32
    Private Declare Function DrawThemeText Lib "uxtheme.dll" (ByVal hTheme As IntPtr, ByVal hDC As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer, ByVal pszText As String, ByVal iCharCount As Integer, ByVal dwTextFlags As Integer, ByVal dwTextFlags2 As Integer, ByRef lpRect As RECT) As Int32

    Private Declare Function CloseThemeData Lib "UxTheme.dll" (ByVal hTheme As IntPtr) As IntPtr
    Private Declare Function CreateCompatibleDC Lib "Gdi32.dll" (ByVal hdc As IntPtr) As IntPtr
    Private Declare Function CreateDIBSection Lib "Gdi32.dll" (ByVal hdc As IntPtr, ByRef pbmi As BITMAPINFO, ByVal usage As Int32, ByVal ppvBits As Int32, ByVal hSection As IntPtr, ByVal offset As Int32) As IntPtr
    Private Declare Function SelectObject Lib "Gdi32.dll" (ByVal hdc As IntPtr, ByVal hObject As IntPtr) As IntPtr
    Private Declare Function DeleteObject Lib "Gdi32.dll" (ByVal hObject As IntPtr) As Boolean
    Private Declare Function DeleteDC Lib "Gdi32.dll" (ByVal hdc As IntPtr) As Boolean
    Private Declare Function CreateFontIndirect Lib "Gdi32.dll" Alias "CreateFontIndirectA" (ByRef lplf As LOGFONTW) As IntPtr
    Private Declare Function BitBlt Lib "Gdi32.dll" (ByVal hDestDC As IntPtr, ByVal x As Int32, ByVal y As Int32, ByVal nWidth As Int32, ByVal nHeight As Int32, ByVal hSrcDC As IntPtr, ByVal xSrc As Int32, ByVal ySrc As Int32, ByVal dwRop As Int32) As Boolean
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As LPPOINT, ByVal Source As IntPtr, ByVal Length As Integer)

    Dim szTitle As String = "发光字很给力,有木有!!!"

    Delegate Function WndProcDelegate(ByVal hWnd As Integer, ByVal msg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
    ' End Function
    'Main WinProc.
    Function WndProc(ByVal hWnd As Integer, ByVal msg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
        Dim fCallDWP As Boolean = True
        Dim fDwmEnabled As Boolean = False
        Dim lRet As IntPtr = 0
        Dim hr As HRESULT = HRESULT.S_OK
        ' 自定义框架问题的Winproc工作进程。
        hr = DwmIsCompositionEnabled(fDwmEnabled)
        If hr >= 0 Then
            lRet = CustomCaptionProc(hWnd, msg, wParam, lParam, fCallDWP)
        End If
        '应用程序其余部分的Winproc工作进程。
        If fCallDWP Then
            lRet = AppWinProc(hWnd, msg, wParam, lParam)
        End If
        Return lRet
    End Function

    '用于处理自定义标题消息的消息处理程序。
    Private Function CustomCaptionProc(ByVal hWnd As IntPtr, ByVal msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr, ByRef pfCallDWP As Boolean) As IntPtr
        Dim lRet As IntPtr = 0
        Dim hr As HRESULT = HRESULT.S_OK
        Dim fCallDWP As Boolean = True '传递到DefWindowProc?
        fCallDWP = Not DwmDefWindowProc(hWnd, msg, wParam, lParam, lRet)
        '处理窗口创建。
        If msg = WM_CREATE Then
            Dim rcClient As New RECT()
            GetWindowRect(hWnd, rcClient)
            '通知应用程序框架更改。
            SetWindowPos(hWnd, 0, rcClient.left, rcClient.top, rcClient.right - rcClient.left, rcClient.bottom - rcClient.top, SWP_FRAMECHANGED)
            fCallDWP = True
            lRet = 0
        End If
        '处理窗口激活。
        If msg = WM_ACTIVATE Then
            '将框架延伸到客户区域。
            Dim margins As MARGINS
            margins.cxLeftWidth = LEFTEXTENDWIDTH     ' 8
            margins.cxRightWidth = RIGHTEXTENDWIDTH    '8
            margins.cyBottomHeight = BOTTOMEXTENDWIDTH '20
            margins.cyTopHeight = TOPEXTENDWIDTH     '27
            hr = DwmExtendFrameIntoClientArea(hWnd, margins)
            If hr < 0 Then
                ' 处理错误。
            End If
            fCallDWP = True
            lRet = 0
        End If
        If msg = WM_PAINT Then
            Dim hdc As IntPtr
            Dim ps As New PAINTSTRUCT()
            ReDim ps.rgbReserved(31)
            hdc = BeginPaint(hWnd, ps)
            PaintCustomCaption(hWnd, hdc)
            EndPaint(hWnd, ps)
            fCallDWP = True
            lRet = 0
        End If
        '处理非客户端大小的消息。
        If msg = WM_NCCALCSIZE And wParam <> 0 Then
            '基于自定义NCA插入计算新的NCCALCSIZE_PARAMS。
            Dim pncsp As New NCCALCSIZE_PARAMS()
            ReDim pncsp.rgrc(2)
            pncsp.rgrc(0).left = pncsp.rgrc(0).left + 0
            pncsp.rgrc(0).top = pncsp.rgrc(0).top + 0
            pncsp.rgrc(0).right = pncsp.rgrc(0).right - 0
            pncsp.rgrc(0).bottom = pncsp.rgrc(0).bottom - 0

            lRet = 0
            '无需将消息传递给DefWindowProc.
            fCallDWP = False
        End If
        '如果不是由DwmDefWindowProc处理，则在NCA中处理命中测试。
        If (msg = WM_NCHITTEST) And (lRet = 0) Then
            lRet = HitTestNCA(hWnd, wParam, lParam)
            If (lRet <> HTNOWHERE) Then fCallDWP = False
        End If
        pfCallDWP = fCallDWP
        Return lRet
    End Function
    '应用程序的消息处理程序。
    Private Function AppWinProc(ByVal hWnd As IntPtr, ByVal msg As UInteger, ByVal wParam As Int32, ByVal lParam As Int32) As IntPtr
        Dim wmId As Int16, wmEvent As Int16
        Dim ps As New PAINTSTRUCT()
        Dim hdc As IntPtr
        Dim result As IntPtr = 0
        Select Case msg
            Case WM_CREATE
            Case WM_COMMAND
                wmId = wParam >> 16
                wmEvent = wParam << 16
                'Parse the menu selections:
                Select Case wmId
                    Case Else
                        Return DefWindowProc(hWnd, msg, wParam, lParam)
                End Select
            Case WM_PAINT
                hdc = BeginPaint(hWnd, ps)
                PaintCustomCaption(hWnd, hdc)
                'Add any drawing code here...
                EndPaint(hWnd, ps)
            Case WM_DESTROY
                PostQuitMessage(0)
            Case Else
                Return DefWindowProc(hWnd, msg, wParam, lParam)
        End Select
        Return 0
    End Function
    '在自定义框架上绘制标题。
    Private Sub PaintCustomCaption(ByVal hWnd As IntPtr, ByVal hDc As IntPtr)
        Dim rcClient As New RECT()
        GetClientRect(hWnd, rcClient)
        Dim myHandle As GCHandle = GCHandle.Alloc("CompositedWindow::Window", GCHandleType.Pinned)
        Dim Address As IntPtr = myHandle.AddrOfPinnedObject()
        myHandle.Free() ' 允许对象实例再移动。
        Dim hTheme As IntPtr = OpenThemeData(0, Address)
        If hTheme Then
            Dim hdcPaint As IntPtr = CreateCompatibleDC(hDc)
            If hdcPaint Then
                Dim cx As Integer = rcClient.right - rcClient.left
                Dim cy As Integer = rcClient.bottom - rcClient.top
                '定义用于绘制文本的BITMAPINFO结构。
                '注意biHeight是负数。之所以这样做是因为DrawThemeTextEx()需要位图从上到下的顺序。
                Dim dib As New BITMAPINFO()
                dib.bmiHeader.biSize = Marshal.SizeOf(dib.bmiHeader)
                dib.bmiHeader.biWidth = cx
                dib.bmiHeader.biHeight = -cy
                dib.bmiHeader.biPlanes = 1
                dib.bmiHeader.biBitCount = 24
                dib.bmiHeader.biCompression = BI_RGB
                Dim hbm As IntPtr = CreateDIBSection(hDc, dib, DIB_RGB_COLORS, 0&, IntPtr.Zero, 0)
                If hbm Then
                    Dim hbmOld As IntPtr = SelectObject(hdcPaint, hbm)
                    '设置主题绘图选项。
                    Dim DttOpts As New DTTOPTS()
                    DttOpts.dwSize = Marshal.SizeOf(DttOpts)
                    DttOpts.dwFlags = DTT_COMPOSITED Or DTT_GLOWSIZE
                    DttOpts.iGlowSize = 15
                    '选择字体。
                    Dim lgFont As New LOGFONTW
                    Dim hFontOld As IntPtr = 0
                    If GetThemeSysFont(hTheme, TMT_CAPTIONFONT, lgFont) = 0 Then
                        Dim hFont As IntPtr = CreateFontIndirect(lgFont)
                        hFontOld = SelectObject(hdcPaint, hFont)
                    End If
                    '画标题。
                    Dim rcPaint As RECT = rcClient
                    rcPaint.top += 8
                    rcPaint.right -= 125
                    rcPaint.left += 8
                    rcPaint.bottom = 50
                    BitBlt(hDc, 0, 0, cx, cy, hdcPaint, rcPaint.left, rcPaint.top, SRCCOPY)
                    Dim p As Int32 = DrawThemeTextEx(hTheme, hdcPaint, 0, 0, szTitle, -1, DT_LEFT Or DT_WORD_ELLIPSIS, rcPaint, DttOpts)
                    '将文本添加到框架中。
                    BitBlt(hdcPaint, rcPaint.left, rcPaint.top, cx, cy, hDc, 0, 0, SRCCOPY)

                    ' BitBlt(m_hDc, 0, 0, rc.Right - rc.Left, rc.Bottom - rc.Top, dsthDc, rc.Left, rc.Top, vbSrcCopy)
                    ' zDrawThemeTextEx = DrawThemeTextEx(hTheme, m_hDc, TEXT_LABEL, 0, StrPtr(sText), -1, dwTextFlags, rc, dts)
                    ' BitBlt(dsthDc, rc.Left, rc.Top, rc.Right - rc.Left, rc.Bottom - rc.Top, m_hDc, 0, 0, vbSrcCopy)

                    SelectObject(hdcPaint, hbmOld)
                    If hFontOld Then
                        SelectObject(hdcPaint, hFontOld)
                    End If
                    DeleteObject(hbm)
                End If
                DeleteDC(hdcPaint)
                DeleteDC(hDc)
            End If
            CloseThemeData(hTheme)
        End If
    End Sub
    ''' <summary>
    '''  Hit test the frame for resizing and moving.
    ''' </summary>
    ''' <param name="hWnd"></param>
    ''' <param name="wParam"></param>
    ''' <param name="lParam"></param>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Private Function HitTestNCA(ByVal hWnd As IntPtr, ByVal wParam As Int32, ByVal lParam As Int32) As Integer
        ' 获取命中测试的点坐标。
        Dim ptMouse As LPPOINT
        ' ptMouse.x = lParam >> 16
        ' ptMouse.y = lParam << 16

        Dim myHandle As GCHandle = GCHandle.Alloc(ptMouse, GCHandleType.Pinned)
        Dim Address As IntPtr = myHandle.AddrOfPinnedObject()
        myHandle.Free() ' 允许对象实例再移动。
        Dim bm(3) As Byte
        CopyMemory(ptMouse, lParam, Marshal.SizeOf(ptMouse))     '取出坐标.
        '获取窗口矩形。
        Dim rcWindow As RECT
        GetWindowRect(hWnd, rcWindow)
        '获取框架矩形，调整为没有字幕的样式。
        Dim rcFrame As New RECT
        AdjustWindowRectEx(rcFrame, WS_OVERLAPPEDWINDOW And Not WS_CAPTION, False, 0)
        '确定命中测试是否用于调整大小。默认中间（1,1）。
        Dim uRow As UShort = 1, uCol As UShort = 1
        Dim fOnResizeBorder As Boolean = False
        '确定该点是在窗口的顶部还是底部。
        If ptMouse.y >= rcWindow.top And ptMouse.y < (rcWindow.top + TOPEXTENDWIDTH) Then
            fOnResizeBorder = (ptMouse.y < (rcWindow.top - rcFrame.top))
            uRow = 0
        ElseIf ptMouse.y < rcWindow.bottom And ptMouse.y >= (rcWindow.bottom - BOTTOMEXTENDWIDTH) Then
            uRow = 2
        End If
        '确定该点是在窗口的左侧还是右侧。
        If ptMouse.x >= rcWindow.left And ptMouse.x < (rcWindow.left + LEFTEXTENDWIDTH) Then
            uCol = 0 'left side
        ElseIf ptMouse.x < rcWindow.right And ptMouse.x >= (rcWindow.right - RIGHTEXTENDWIDTH) Then
            uCol = 2 ' right side
        End If
        'Hit test (HTTOPLEFT, ... HTBOTTOMRIGHT)
        Dim hitTests(2, 2) As Integer
        '    { HTTOPLEFT,    fOnResizeBorder ? HTTOP : HTCAPTION,    HTTOPRIGHT },
        '{ HTLEFT,       HTNOWHERE,     HTRIGHT },
        '{ HTBOTTOMLEFT, HTBOTTOM, HTBOTTOMRIGHT },
        hitTests(0, 0) = HTTOPLEFT
        hitTests(1, 0) = IIf(fOnResizeBorder, HTTOP, HTCAPTION)
        hitTests(2, 0) = HTTOPRIGHT
        hitTests(0, 1) = HTLEFT
        hitTests(1, 1) = HTNOWHERE
        hitTests(2, 1) = HTRIGHT
        hitTests(0, 2) = HTBOTTOMLEFT
        hitTests(1, 2) = HTBOTTOM
        hitTests(2, 2) = HTBOTTOMRIGHT
        Return hitTests(uRow, uCol)
    End Function
End Module
